(**
 * top level module of smlformat.
 * <p>
 * The tasks of this module are
 * <ul>
 *   <li>parses the source code</li>
 *   <li>generates codes of formatters</li>
 *   <li>outputs codes into a destination stream</li>
 * </ul>
 * </p>
 * @author YAMATODANI Kiyoshi
 * @copyright (C) 2021 SML# Development Team.
 * @version $Id: PPGMain.sml,v 1.14 2008/08/10 13:44:01 kiyoshiy Exp $
 *)
structure PPGMain :
  sig
    exception Error of string list
    val main :
        {
          sourceFileName : string,
          sourceStream : TextIO.instream,
          destinationStream : TextIO.outstream,
          withLineDirective : bool,
          separationMode : string option
        } -> unit
  end =
struct

  (***************************************************************************)

  structure EQ = ErrorQueue
  structure FG = FormatterGenerator
  structure U = Utility

  (***************************************************************************)

  exception Error of string list

  (***************************************************************************)

  (**
   * get the offset of the end of region.
   * @params region
   * @param region a region gotten from ML-lex.
   * @return offset of the end of the region from the beginning of the source
   *         code
   *)
  fun regionToEndPos ((left, right) : Ast.region) = right

  (**
   * adjust the position which ML-lex gives into the correct position 
   * <p>
   *  The 'yypos' generated by ML-lex equals to the actual offset from the
   * start of source code plus 2. (This is a bug of ML-lex ?)
   * </p>
   *)
  fun adjustLexPos lexpos = lexpos - Constants.INITIAL_POS_OF_LEXER

  datatype context =
      STRUCTURE of context * string
    | FUNCTOR of context * string
    | ABSTYPE of context
    | LOCAL of context
    | TOPLEVEL

  (****************************************)

  (**
   * generates formatter codes for a declaration.
   * @params formatterEnv (regionOpt, dec)
   * @param formatterEnv the formatterEnv which contains previously defined
   *                 formatters.
   * @param regionOpt option of the region of the dec in the source code.
   * @param dec a declaration
   * @return a pair of
   *   <ul>
   *     <li>an updated formatterEnv</li>
   *     <li>a list of pairs of
   *       <ul>
   *          <li>the position where to insert the generated formatter code.
   *              </li>
   *          <li>the generated code of formatter</li>
   *       </ul>
   *       </li>
   *   </ul>
   *)
  fun generateForDec F (context, dec) =
      (case dec of
         Ast.DatatypeDec {formatComments = _::_, region, ...} =>
         let val (codes, F') = FG.generateForDataTypeDec F (region, dec)
         in (F', [(context, regionToEndPos region, codes)]) end

       | Ast.TypeDec {formatComments = _::_, region, ...} =>
         let val (codes, F') = FG.generateForTypeDec F (region, dec)
         in (F', [(context, regionToEndPos region, codes)]) end

       | Ast.AbstypeDec
         {
           formatComments = formatComments as _::_,
           abstycs,
           withtycs,
           bodyBeginPos,
           region,
           ...
         } =>
         let
           val datatypeDec =
               Ast.DatatypeDec
               {
                 formatComments = formatComments,
                 datatycs = abstycs,
                 withtycs = withtycs,
                 region = region
               }
           val (codes, F') =
               FG.generateForDataTypeDec F (region, datatypeDec)
         in (F', [(ABSTYPE context, bodyBeginPos, codes)]) end

       | Ast.LocalDec (localDec, globalDec) =>
         let
           val (F', codesForLocalDec) = generateForDec F (LOCAL context, localDec)
           val (F'', codesForGlobalDec) =  generateForDec F' (context, globalDec)
           val F''' = F'' (* ToDo : F'' = F + globalDec *)
         in
           (F''', codesForLocalDec @ codesForGlobalDec)
         end

       | Ast.SeqDec decs =>
         foldl
             (fn (dec, (F, codes)) =>
                 let val (F', codes') = generateForDec F (context, dec)
                 in (F', codes @ codes')
                 end)
             (F, [])
             decs

       | Ast.StrDec structureBinds =>
         let
           fun getStructureBind (Ast.Strb bind) = bind
         in
           foldl
               (fn (bind, (F, codes)) =>
                   let
                     val {name, def, ...} =
                         getStructureBind bind
                     val (F', codes') = generateForStructure F (STRUCTURE (context, name), def)
                   in (F', codes @ codes')
                   end)
               (F, [])
               structureBinds
         end

       | Ast.FctDec functorBinds =>
         let
           fun getFunctorBind (Ast.Fctb bind) = bind
         in
           foldl
               (fn (bind, (F, codes)) =>
                   let
                     val {name, def, ...} =
                         getFunctorBind bind
                     val (F', codes') = generateForFunctor F (FUNCTOR (context, name), def)
                   in (F', codes @ codes')
                   end)
               (F, [])
               functorBinds
         end

       | Ast.ExceptionDec {formatComments = _::_, region, ...} =>
         let val (codes, F') = FG.generateForExceptionDec F (region, dec)
         in (F', [(context, regionToEndPos region, codes)]) end

       | _ => (F, []))
      handle exn as FG.GenerationError _ => (EQ.add (EQ.Error exn); (F, []))

  (**
   * generates formatter codes for a structure.
   * @params formatterEnv (region, strexp)
   * @param formatterEnv the formatterEnv which contains previously defined
   *                 formatters.
   * @param strexp the structure expression
   * @return a pair of
   *   <ul>
   *     <li>an updated formatterEnv</li>
   *     <li>a list of pairs of
   *       <ul>
   *          <li>the region of declaration for which a formatter is generated
   *              </li>
   *          <li>the generated code of formatter</li>
   *       </ul>
   *       </li>
   *   </ul>
   *)
  and generateForStructure F (context, Ast.BaseStr dec) =
      generateForDec F (context, dec)

    | generateForStructure F (context, Ast.LetStr(dec, str)) =
      let
        val (F', codesForDec) = generateForDec F (LOCAL context, dec)
        val (F'', codesForStr) = generateForStructure F' (context, str)
      in (F'', codesForDec @ codesForStr) end

    | generateForStructure F _ = (F, [])

  and generateForFunctor F (context, Ast.BaseFct {body,...}) =
      generateForStructure F (context, body)

    | generateForFunctor F (context, Ast.LetFct(dec, str)) =
      let
        val (F', codesForDec) = generateForDec F (LOCAL context, dec)
        val (F'', codesForFct) = generateForFunctor F' (context, str)
      in (F'', codesForDec @ codesForFct) end

    | generateForFunctor F _ = (F, [])

  (****************************************)

  (**
   *  generates a file which contains codes of formatters for the type/datatype
   * defined in the souce file.
   *
   * @params
   *    {sourceFileName, sourceStream, destinationStream, withLineDirective}
   * @param sourceFileName name of the SML source file which contains
   *               type/datatype declarations annotated with format comments.
   * @param sourceStream the stream of SML source code
   * @param destinationStream the stream to which the generated code is emit
   * @param withLineDirective if true, line directives should be inserted in
   *         the result code to point positions in the original source code.
   * @return unit
   *)
  fun main
        {sourceFileName, sourceStream, destinationStream, withLineDirective,
         separationMode} =
      let
        (* the all contents of source stream is pulled out here,
         * because the source code is scanned twice in the following process.
         *)
        val sourceCode = TextIO.inputAll sourceStream

        (* parse *)
        val (decs, posToLocation) =
            MLParser.parse (sourceFileName, sourceCode)
            handle MLParser.ParseError messages =>
                   raise Error messages

        (* generates formatters *)
        val F = BasicFormattersEnv.basicFormattersEnv
        val _ = ErrorQueue.initialize ()
        val (F, codes) =
            (foldl
             (fn(dec, (F, codes)) =>
                let val (F, codes') = generateForDec F (TOPLEVEL, dec)
                in (F, codes @ codes') end)
             (F, [])
             decs)
        val _ = case ErrorQueue.getAll () of
                  [] => ()
                | errors =>
                  let
                    fun toString
                        (EQ.Error(FG.GenerationError(message, region))) =
                        MLParser.getErrorMessage
                            sourceFileName
                            posToLocation
                            (message, region)
                      | toString (EQ.Error exn) =
                        raise Fail ("BUG: unknown exception:" ^ exnMessage exn)
                      | toString _ = raise Fail "BUG: impossible exception"
                    val messages = map toString errors
                  in raise Error messages end

        local
          (* collect formatters for which the destination tag is specified. *)
          val customPositionCodes =
              foldl
              (fn ((_, _, codes), accum) =>
                  (List.filter (fn (SOME _, _) => true | _ => false) codes) @
                  accum)
              []
              codes
        in
        (**
         * replaces anchor strings in the text with codes of formatters.
         * @params text
         * @param text a string in which anchor strings may be included
         * @return a new string 
         *)
        fun replaceFormatters text =
            foldl
            (fn ((SOME anchor, code), text) =>
                let val (_, newText) = U.replaceString anchor code text
                in newText end
              | _ => raise Fail "BUG: NONE of anchor text"
            )
            text
            customPositionCodes
        end

        (**
         *  outputs source code in which generated formatters are inserted at
         * appropriate location.
         * @params sourceStream readChars position texts codes
         * @param sourceStream the stream from which source code is read.
         * @param readChars the number of chars which have been read from
         *                   the source stream so far.
         * @param position current position
         * @param texts intermediate result of merge of source code and
         *             generated code. They are in reversed order.
         * @param codes a list of codes of generated formatters
         * @return source code in which generated codes are inserted
         *         at appropriate positions.
         *)
        fun merge sourceStream readChars pos texts =
         fn [] => rev ((TextIO.inputAll sourceStream) :: texts)
          | ((_, insertPosition, codes)::tail) =>
            let
              val toCopy = (adjustLexPos (insertPosition + 1)) - readChars
              val input = TextIO.inputN (sourceStream, toCopy)
              (* get pos at the end of input. *)
              val pos as (line, col) =
                  CharVector.foldl
                      (fn (c, (line, col)) =>
                          case c
                           of #"\n" => (line + 1, 1)
                            | _  => (line, col + 1))
                      pos
                      input
              (* This line directive points at the end of input. *)
              val directive =
                  if withLineDirective
                  then 
                    String.concat
                        ["(*#line ", Int.toString line, ".", Int.toString col,
                         " \"", sourceFileName, "\"*)"]
                  else ""
              val generatedCode = 
                  String.concat
                      (U.interleave
                           "\n"
                           (map
                                (fn (_, code) => code)
                                (List.filter
                                     (fn (NONE, _) => true | _ => false)
                                     codes)))
              (* new texts are prepended. they are reversed at last. *)
              val newTexts =
                  directive :: generatedCode :: (input ^ "\n") :: texts
            in
              merge sourceStream (readChars + toCopy) pos newTexts tail
            end

        fun localOpen pos context =
            let
              fun error msg =
                  raise Error [MLParser.getErrorMessage
                                 sourceFileName
                                 posToLocation
                                 (msg, (pos, pos))]
            in
              case context of
                TOPLEVEL => nil
              | STRUCTURE (c, id) => localOpen pos c @ [id]
              | FUNCTOR _ =>
                error "cannot generate formatters in functor in separation mode"
              | ABSTYPE _ =>
                error "cannot generate formatters in abstype in separation mode"
              | LOCAL _ =>
                error "cannot generate local formatters in separation mode"
            end

        fun serialize codes =
            map (fn (context, pos, codes) =>
                    let
                      val code =
                          String.concat (map (fn (_, code) => code) codes)
                    in
                      case localOpen pos context of
                        nil => code
                      | p => "local open " ^ String.concatWith "." p ^ " in\n"
                             ^ code ^ " end\n"
                    end)
                codes

        val replaced =
            case separationMode of
              NONE =>
              map replaceFormatters
                  (merge (TextIO.openString sourceCode) 0 (1, 1) [] codes)
            | SOME "" =>
              serialize codes
            | SOME strid =>
              ("structure " ^ strid ^ " = struct\n")
              :: serialize codes @ [" end\n"]
      in
        app (fn text => TextIO.output (destinationStream, text)) replaced
      end

  (***************************************************************************)

end;
